;;; heap.ss  --  Jens Axel S?gaard  --  Easter 2003, October 2003

;;; PURPOSE

; This file contains implementations of various heaps.
; The algorithms are carefully explained by Chris Okasaki in
; the delightful book "Purely Functional Data Structures".

; The heaps are implemented in a purely functional way. Inserting
; an element x in a heap h using (insert x h) will return a new heap h'
; containing x and all elements in h *without* destroying the old heap h.
; The heaps can thus be used *persistently* opposed to the normal 
; *ephemeral* way, where the old heap are destroyed.

;;; HEAP ALGORITHMS
;  - leftist heaps
;  - binomial heaps
;  - pairing-heaps
;  - splay heaps
;  - lazy binomial heaps
;  - lazy pairing heaps
;  - skew binomial heaps

;;; FUNCTORS
;  - bootstrap-heap:      
;      make efficient merging heaps
;  - explit-min functor:  
;      improves the worst case time of find-min to O(1)

;;; REFERENCES 
;  [Oka] "Purely Functional Data Structures", Chris Okasaki 

(module heap mzscheme  
  (provide (all-defined))
  
  (require (lib "plt-pretty-big-text.ss" "lang"))
  (require "ordered.ss")
  
  ;;; HEAPS
  
  ; The Heap Signature
  (define-signature heap^    
    (empty
     empty? 
     insert
     insert*
     xinsert
     merge
     find-min
     delete-min
     ))
  
  ; instantiate-heap : heap-unit ordered-unit -> compound-unit
  ;  return heap-unit representing a heap of alpha elements
  (define (instantiate-heap heap@ order@)
    (compound-unit/sig 
      (import)
      (link (ALPHA      : ordered^ (order@))
            (ALPHA-HEAP : heap^    (heap@ ALPHA)))
      (export (open ALPHA-HEAP))))
  
  
  ; Thanks to John Clements for this incantation.
  (define-syntax (use-heap stx)
    (syntax-case stx ()
      [(_ heap-unit)
       (datum->syntax-object stx `(,#`define-values/invoke-unit/sig heap^ ,#`heap-unit))]
      [(_ heap-unit prefix) 
       (datum->syntax-object stx `(,#`define-values/invoke-unit/sig heap^ ,#`heap-unit ,#`prefix))]))
  
  
  
  ; Example:
  ;     (define integer-heap@ (instantiate-heap binomial-heap@ integers@))
  ;  is equivalent to
  ;     (define integer-heap@
  ;       (compound-unit/sig 
  ;         (import)
  ;           (link (INTEGERS     : ordered^ (integers@))
  ;                 (INTEGER-HEAP : heap^    (heap@ INTEGERS)))
  ;         (export (open INTEGER-HEAP))))
  
  
  ;;; BOOTSTRAPPING HEAPS WITH EFFICIENT MERGING
  
  ; Given a heap implementation where insert takes time O(1) and
  ; merge, find-min and delete-min take O(log n) worst case, the 
  ; following functor produces a heap implementation, where the 
  ; times for find-min and merge are improved to O(1) worst case.
  
  (define (bootstrap-heap heap@ element-order@)
    (unit/sig heap^
      (import)
      (define-values/invoke-unit/sig ordered^ element-order@ element)
      
      ; A BOOTSTRAPPED HEAP is either
      ;     empty
      ; or
      ;     (make-node elm primitive)
      ; where elm is an element and primitive is a
      ; primitive heap of boot strapped heaps.
      
      (define empty '())
      (define empty? null?)
      
      (define-struct bnode (elm primitive))
      (define root bnode-elm)
      (define primitive bnode-primitive)
      
      (define bootstrapped-order@
        (predicates->ordered (lambda (h1 h2)
                               (element:elm= (root h1) (root h2)))
                             (lambda (h1 h2)
                               (element:elm< (root h1) (root h2)))
                             (lambda (h1 h2)
                               (element:elm<= (root h1) (root h2)))))
      
      (define primitive-of-bootstrapped@ (instantiate-heap heap@ bootstrapped-order@))
      
      (define-values/invoke-unit/sig heap^ primitive-of-bootstrapped@ primitive)
      ;(define-values/invoke-unit/sig ordered^ bootstrapped-order@ bootstrapped)
      
      (define (find-min bh)
        (root bh))
      
      (define (merge h1 h2)
        (cond
          [(empty? h1)  h2]
          [(empty? h2)  h1]   
          [else         (if (element:elm< (root h1) (root h2))
                            (make-bnode (root h1) (primitive:insert (primitive h1) h2))
                            (make-bnode (root h2) (primitive:insert (primitive h2) h1)))]))
      
      (define (insert bh x)
        (merge (make-bnode x primitive:empty) bh))

      (define (xinsert x h) 
        (insert h x))

      (define (insert* bh xs)
        (foldl xinsert bh xs))
      
      (define (delete-min bh)
        (if (primitive:empty? (primitive bh))
            empty
            (let ([p (primitive:find-min   (primitive bh))]
                  [d (primitive:delete-min (primitive bh))])
              (make-bnode (root p)
                          (primitive:merge (primitive p)
                                           d)))))))
  
  
  ;;; LEFTIST HEAP [Oka, p.17-20]
  
  ; A *Leftist heap* is a heap-ordered binary tree with the *leftist property*:
  ; The rank of any left child is at least as large as the rank of its right sibling.
  ; The *rank* of a node is the length of the its *right spine*, which is the
  ; rightmost path from the node to an empty node.
  
  ;;; Time             worst case
  ;  empty    O(1)
  ;  empty?             O(1)
  ;  insert             O(log n)
  ;  merge              O(log n)
  ;  find-min           O(1)
  ;  delete-min         O(log n)
  
  ; The signed heap unit
  (define leftist-heap@ 
    (unit/sig heap^ 
      (import ordered^)
      
      ; A HEAP is either 
      ;    empty
      ; or 
      ;    (make-node rank left right)
      ; where rank is an integer and left, right are heaps.
      
      (define empty '())
      (define empty? null?)
      
      (define-struct node (rank elm left right))
      
      (define (merge h1 h2)
        (cond
          [(empty? h1) h2]
          [(empty? h2) h1]
          [else        (let ([x (node-elm h1)]
                             [y (node-elm h2)])
                         (if (elm<= x y)
                             (make-heap x (node-left h1) (merge (node-right h1) h2))
                             (make-heap y (node-left h2) (merge h1 (node-right h2)))))]))
      
      (define (rank h)
        (if (empty? h)
            0
            (node-rank h)))
      
      (define (make-heap x a b)
        (let ([ra (rank a)]
              [rb (rank b)])
          (if (>= ra rb)
              (make-node (add1 rb) x a b)
              (make-node (add1 ra) x b a))))
      
      (define (insert h x)
        (merge (make-node 1 x empty empty) h))

      (define (xinsert x h) 
        (insert h x))

      (define (insert* h xs)
        (foldl xinsert h xs))

      (define (find-min h)
        (node-elm h))
      
      (define (delete-min h)
        (merge (node-left h) (node-right h)))
      
      ))
  
  ;;; BINOMIAL HEAP [Oka,p. 21-24]
  
  ; A binomial heap is a list of binomial trees.
  ; A *binomial tree* of rank 0 is a singleton node.
  ; A *binomial tree* of rank r+1 is made by linking two 
  ; binomial trees of rank r. One tree is made the leftmost 
  ; child of the other.
  
  ; Time               worst case   amortized
  ;  empty    O(1)         O(1)
  ;  empty?             O(1)         O(1)
  ;  insert             O(log n)     O(1)
  ;  merge              O(log n)     O(log n)
  ;  find-min           O(log n)     O(log n)   *) use the explicit-min-heap functor to get O(1)
  ;  delete-min         O(log n)     O(log n)
  
  ;;; TODO 
  ;  Exercise 3.5 
  ;   - define find-min directly
  ;  Exercise 3.6
  ;  Exercise 3.7
  
  (define binomial-heap@ 
    (unit/sig heap^ 
      (import ordered^)
      
      ; A BINOMIAL TREE is 
      ;     empty 
      ; or 
      ;    (make-node rank elm tree-list)
      ; where rank is an integer, elm is an element and tree-list is
      ; a list of children trees. 
      
      (define empty '())    
      (define-struct node (rank elm tree-list))
      
      (define (rank n) (node-rank n))
      (define (root n) (node-elm n))
      (define empty? null?)
      
      
      ; A BINOMIAL HEAP is a 
      ;    (list binomial-tree),
      ; where the list of trees are in increasing order of rank.
      
      
      ; link : binomial-tree binomial-tree -> binomial-tree
      ;  link two trees making one tree the leftmost child of the other
      (define (link t1 t2)
        (let ([x1 (node-elm t1)]
              [x2 (node-elm t2)]
              [r  (node-rank t1)])
          (if (elm<= x1 x2)
              (make-node (add1 r) x1 (cons t2 (node-tree-list t1)))
              (make-node (add1 r) x2 (cons t1 (node-tree-list t2))))))
      
      
      ; insert-tree : binomial-tree (list binomial-tree) -> (list binomial-tree)
      ;   the list returned is ordered by rank. Trees of equal rank is linked.
      (define (insert-tree t ts)
        (if (null? ts)
            (list t)
            (if (< (rank t) (rank (first ts)))
                (cons t ts)
                (insert-tree (link t (first ts)) (rest ts)))))
      
      
      ; insert : element (list binomial-trees) -> (list binomial-trees)
      (define (insert ts x)
        (insert-tree (make-node 0 x '()) ts))

      (define (xinsert x h) 
        (insert h x))

      (define (insert* ts xs)
        (foldl xinsert ts xs))

      ; merge : (list binomial-trees) (list binomial-trees) -> (list binomial-trees)
      (define (merge ts1 ts2)
        (cond
          [(null? ts1)                                ts2]
          [(null? ts2)                                ts1]
          [(< (rank (first ts1)) (rank (first ts2)))  (cons (first ts1) (merge (rest ts1) ts2))]
          [(< (rank (first ts2)) (rank (first ts1)))  (cons (first ts2) (merge (rest ts2) ts1))]
          [else                                       (insert-tree (link (first ts1) (first ts2))
                                                                   (merge (rest ts1) (rest ts2)))]))
      
      (define (remove-min-tree ts)
        (if (null? (rest ts))
            (list (first ts) '())
            (let ([r (remove-min-tree (rest ts))])
              (if (elm<= (root (first ts)) (root (first r)))
                  (list (first ts) (rest ts))
                  (list (first r) (cons (first ts) (second r)))))))
      
      (define (find-min ts)
        (root (first (remove-min-tree ts))))
      
      (define (delete-min ts)
        (let ([p (remove-min-tree ts)])
          (merge (reverse (node-tree-list (first p)))
                 (second p))))))
  
  ;;; PAIRING HEAP [Oka,p. 52-54]
  
  ; For ephemeral applications (i.e. not for persistence)
  
  ; Hint: For applications that do not use merge, pairing heaps
  ;       are almost as fast as splay trees.
  ;       For applications that use merge, paring heaps are much
  ;       faster.
  
  ; Time               worst case   amortized
  ;                                (ephemeral)
  ;  empty    O(1)         O(1)
  ;  empty?             O(1)         O(1)
  ;  find-min           O(1)         O(1)   
  ;  insert             O(1)         O(log n) \ conjectured better: O(1)
  ;  merge              O(1)         O(log n) /
  ;  delete-min         O(n)         O(log n) 
  
  (define pairing-heap@ 
    (unit/sig heap^ 
      (import ordered^)
      ; A PAIRING HEAP is 
      ;    '()
      ; or 
      ;    (make-node elm heap-list)
      ; where elm is an element and heap-list is a list of heap-ordered trees. 
      
      (define empty '())
      (define-struct node (elm heap-list))
      (define (root n) (node-elm n))
      
      (define empty? null?)
      
      (define (find-min n)
        (node-elm n))
      
      ; merge : heap heap -> heap
      (define (merge h1 h2)
        (cond
          [(empty? h1)                                h2]
          [(empty? h2)                                h1]
          [else (let ([x (node-elm h1)]
                      [y (node-elm h2)])
                  (if (elm<= x y) 
                      (make-node x (cons h2 (node-heap-list h1)))
                      (make-node y (cons h1 (node-heap-list h2)))))]))
      
      ; insert : element heap -> heap
      (define (insert h x)
        (merge (make-node x empty) h))

      (define (xinsert x h) 
        (insert h x))
      
      (define (insert* h xs)
        (foldl xinsert h xs))

      ; merge-heap-pairs : (list heap) -> heap
      (define (merge-heap-pairs hl)
        (cond
          [(null? hl)        empty]
          [(null? (rest hl)) (first hl)]
          [else              (merge (merge (first hl) (second hl))
                                    (merge-heap-pairs (rest (rest hl))))]))
      
      ; delete-min : heap -> heap
      (define (delete-min h)
        (merge-heap-pairs (node-heap-list h)))))
  
  ;;; LAZY PAIRING HEAP [Oka,p. 79-80]
  
  ; Hint:
  ;   This version of pairing heaps can handle persistent use.
  ;   Due to the use of delay/force it is however slow, if one
  ;   does not heavily use persistence.
  
  ; Time               worst case   amortized
  ;                                (persistent)
  ;  empty    O(1)         O(1) 
  ;  empty?             O(1)         O(1) 
  ;  find-min           O(1)         O(1)     ?  
  ;  insert             O(1)         O(log n) ? \ conjectured better: O(1)
  ;  merge              O(1)         O(log n) ? /
  ;  delete-min         O(n)         O(log n) ?
  
  (define lazy-pairing-heap@ 
    (unit/sig heap^ 
      (import ordered^)
      
      ; A LAZY PAIRING HEAP is 
      ;    empty
      ; or 
      ;    (make-node elm heap (promise heap) )
      ; where elm is an element and (promise heap) is a promise that evaluates to a heap. 
      
      (define empty '())
      (define empty? null?)
      (define-struct node (elm heap promise))
      (define (root n) (node-elm n))    
      
      (define (find-min n)
        (node-elm n))
      
      ; merge : heap heap -> heap
      (define (merge h1 h2)
        (cond
          [(empty? h1)  h2]
          [(empty? h2)  h1]
          [else         (let ([x (node-elm h1)]
                              [y (node-elm h2)])
                          (if (elm<= x y)
                              (link h1 h2)
                              (link h2 h1)))]))
      
      (define (link h a)
        (if (empty? (node-heap h))
            (make-node (node-elm h) a (node-promise h))
            (make-node (node-elm h)
                       empty
                       (delay (merge (merge a (node-heap h))
                                     (force (node-promise h)))))))
      
      ; insert : element heap -> heap
      (define (insert h x)
        (merge (make-node x empty (delay empty)) h))

      (define (xinsert x h) 
        (insert h x))
      
      (define (insert* h xs)
        (foldl xinsert h xs))

      ; delete-min : heap -> heap
      (define (delete-min h)
        (merge (node-heap h) (force (node-promise h))))))
  
  ;;; SPLAY HEAP [Oka,p. 46-52]
  
  ; Hint: For applications that do not use merge and do not rely on 
  ;       persistence, splay heaps (using the explicit-min-functor) is the
  ;       fastest implementation of heaps.
  
  ; Time               worst case   amortized
  ;                                (ephemeral)
  ;  empty    O(1)         O(1)
  ;  empty?             O(1)         O(1)
  ;  find-min           O(1)         O(1)   
  ;  insert             O(1)         O(...) \ 
  ;  merge              O(1)         O(...) /
  ;  delete-min         O(n)         O(...) 
  
  (define splay-heap@ 
    (unit/sig heap^ 
      (import ordered^)
      ; A SPLAY HEAP is 
      ;    '()
      ; or 
      ;    (make-node left elm right)
      ; where elm is an element, and left and right are splay heaps.
      
      (define-struct node (left elm right))
      (define (root n) (node-elm n))
      (define left node-left)
      (define right node-right)
      
      (define empty '())
      (define empty? null?)
      
      ; find-min : heap -> element
      (define (find-min n)
        (if (empty? (left n))
            (root n)
            (find-min (left n))))
      
      ; insert : element heap -> heap
      (define (insert h x)
        (let* ([p (partion x h)]
               [a (car p)]
               [b (cdr p)])
          (make-node a x b)))
      
      (define (xinsert x h) 
        (insert h x))
      
      (define (insert* h xs)
        (foldl xinsert h xs))

      ; partion : element heap -> (cons heap heap)
      (define (partion pivot h)
        (if (empty? h)
            (cons empty empty)
            (let ([a (left h)]
                  [x (root h)]
                  [b (right h)])
              (if (elm<= x pivot)
                  (if (empty? b)
                      (cons h empty)
                      (let ([b1 (left b)]
                            [y  (root b)]
                            [b2 (right b)])
                        (if (elm<= y pivot)
                            (let* ([p (partion pivot b2)]
                                   [small (car p)]
                                   [big   (cdr p)])
                              (cons (make-node (make-node a x b1)
                                               y
                                               small)
                                    big))
                            (let* ([p (partion pivot b1)]
                                   [small (car p)]
                                   [big   (cdr p)])
                              (cons (make-node a x small)
                                    (make-node big y b2))))))
                  (if (empty? a)
                      (cons empty h)
                      (let ([a1 (left a)]
                            [y  (root a)]
                            [a2 (right a)])
                        (if (elm<= y pivot)
                            (let* ([p (partion pivot a2)]
                                   [small (car p)]
                                   [big   (cdr p)])
                              (cons (make-node a1 y small)
                                    (make-node big x b)))
                            (let* ([p (partion pivot a1)]
                                   [small (car p)]
                                   [big   (cdr p)])
                              (cons small
                                    (make-node big
                                               y
                                               (make-node a2 x b)))))))))))
      
      ; merge : heap heap -> heap
      (define (merge h1 h2)
        (cond
          [(empty? h1) h2]
          [(empty? h2) h1]
          [else             (let ([a (left h1)]
                                  [x (root h1)]
                                  [b (right h1)])
                              (let* ([p (partion x h2)]
                                     [ta (car p)]
                                     [tb (cdr p)])
                                (make-node (merge ta a)
                                           x
                                           (merge tb b))))]))
      
      ; delete-min : heap -> heap
      (define (delete-min h)
        (cond
          [(empty?                  (left h)) (right h)]
          [(empty? (left (left h))) (make-node (right (left h)) (root h) (right h))]
          [else                          (make-node (delete-min (left (left h)))
                                                    (root (left h))
                                                    (make-node (right (left h))
                                                               (root h)
                                                               (right h)))]))))
  
  
  ;;; LAZY BINOMIAL HEAP [Oka,p. 70-71]
  
  (define lazy-binomial-heap@ 
    (unit/sig heap^ 
      (import ordered^)
      
      ; A LAZY BINOMIAL HEAP is a suspended list of trees,
      ; in increasing order of rank.
      
      ; A BINOMIAL TREE is a
      ;     '())
      ; or 
      ;    (make-node rank elm tree-list)
      ; where rank is an integer, elm is an element and tree-list is
      ; a list of children trees. 
      
      (define-struct node (rank elm tree-list))
      (define (rank n) (node-rank n))
      (define (root n) (node-elm n))
      
      (define empty (delay '()))
      
      (define (empty? h)
        (null? (force h)))
      
      ; link : binomial-tree binomial-tree -> binomial-tree
      ;  link two trees making one tree the leftmost child of the other
      (define (link t1 t2)
        (let ([x1 (node-elm t1)]
              [x2 (node-elm t2)]
              [r  (node-rank t1)])
          (if (elm<= x1 x2)
              (make-node (add1 r) x1 (cons t2 (node-tree-list t1)))
              (make-node (add1 r) x2 (cons t1 (node-tree-list t2))))))
      
      
      ; insert-tree : binomial-tree (list binomial-tree) -> (list binomial-tree)
      ;   the list returned is ordered by rank. Trees of equal rank is linked.
      (define (insert-tree t ts)
        (if (null? ts)
            (list t)
            (if (< (rank t) (rank (first ts)))
                (cons t ts)
                (insert-tree (link t (first ts)) (rest ts)))))
      
      
      ; insert : element (promise (list binomial-trees)) -> (promise (list binomial-trees))
      (define (insert ts x)
        (delay (insert-tree (make-node 0 x '()) (force ts))))

      (define (xinsert x h) 
        (insert h x))
      
      (define (insert* ts xs)
        (foldl xinsert ts xs))

      (define (merge ts1 ts2)
        (delay (mrg (force ts1) (force ts2))))
      
      ; mrg : (list binomial-trees) (list binomial-trees) -> (list binomial-trees)
      (define (mrg ts1 ts2)
        (cond
          [(null? ts1)                                ts2]
          [(null? ts2)                                ts1]
          [(< (rank (first ts1)) (rank (first ts2)))  (cons (first ts1) (mrg (rest ts1) ts2))]
          [(< (rank (first ts2)) (rank (first ts1)))  (cons (first ts2) (mrg (rest ts2) ts1))]
          [else                                       (insert-tree (link (first ts1) (first ts2))
                                                                   (mrg (rest ts1) (rest ts2)))]))
      
      (define (remove-min-tree ts)
        (if (null? (rest ts))
            (list (first ts) '())
            (let ([r (remove-min-tree (rest ts))])
              (if (elm<= (root (first ts)) (root (first r)))
                  (list (first ts) (rest ts))
                  (list (first r) (cons (first ts) (second r)))))))
      
      (define (find-min ts)
        (root (first (remove-min-tree (force ts)))))
      
      (define (delete-min ts)
        (let ([p (remove-min-tree (force ts))])
          (delay (mrg (reverse (node-tree-list (first p)))
                      (second p)))))))
  
  ;;; SKEW BINOMIAL HEAP [Oka,p. 135-138]
  
  (define skew-binomial-heap@ 
    (unit/sig heap^ 
      (import ordered^)
      
      ; A SKEW BINOMIAL TREE is 
      ;    'empty-tree
      ; or 
      ;    (make-node rank elm elm-list tree-list)
      ; where rank is an integer, elm is an element, elm-list is a list of elements
      ; and tree-list is a list of children trees. 
      
      (define empty-tree 'empty-tree)
      (define (empty-tree? h) (eq? 'empty-tree h))
      (define-struct node (rank elm elm-list tree-list))
      (define (rank n) (node-rank n))
      (define (root n) (node-elm n))
      
      ; A SKEW BINOMIAL HEAP is a 
      ;    (list skew-binomial-tree),
      ; where the list of heap ordered trees are in increasing order of rank,
      ; except the first two trees can share rank.
      
      (define empty '())
      (define empty? null?)
      
      ; link : skew-binomial-tree skew-binomial-tree -> skew-binomial-tree
      ;  link two trees making one tree the leftmost child of the other,
      ;  combining to trees of rank r to one tree with rank r+1.
      (define (link t1 t2)
        (let ([x1 (root t1)]
              [x2 (root t2)]
              [r  (rank t1)])
          (if (elm<= x1 x2)
              (make-node (add1 r) x1 (node-elm-list t1) (cons t2 (node-tree-list t1)))
              (make-node (add1 r) x2 (node-elm-list t2) (cons t1 (node-tree-list t2))))))
      
      ; skew-link : element skew-binomial-tree skew-binomial-tree -> skew-binomial-tree
      (define (skew-link x t1 t2)
        (let ([n (link t1 t2)])
          (let ([y (root n)]
                [r (rank n)])
            (if (elm<= x y)
                (make-node r x (cons y (node-elm-list n)) (node-tree-list n))
                (make-node r y (cons x (node-elm-list n)) (node-tree-list n))))))
      
      
      ; insert : element (list skew-binomial-trees) -> (list skew-binomial-trees)
      (define (insert ts x)
        (if (or (null? ts) 
                (null? (rest ts))
                ; (null? (rest (rest ts)))
                )
            (cons (make-node 0 x '() '()) ts)
            (let* ([t1 (car ts)]
                   [t2 (cadr ts)])
              (if (= (rank t1) (rank t2))
                  (cons (skew-link x t1 t2) (rest (rest ts)))
                  (cons (make-node 0 x '() '()) ts)))))

      (define (xinsert x h) 
        (insert h x))
      
      (define (insert* ts xs)
        (foldl xinsert ts xs))


      (define (merge ts1 ts2)
        (merge-trees (normalize ts1) (normalize ts2)))    
      
      (define (normalize ts)
        (if (empty? ts)
            empty
            (insert-tree (first ts) (rest ts))))
      
      ; merge-trees : (list skew-binomial-trees) (list skew-binomial-trees) -> (list skew-binomial-trees)
      (define (merge-trees ts1 ts2)
        (cond
          [(null? ts1)                                ts2]
          [(null? ts2)                                ts1]
          [(< (rank (first ts1)) (rank (first ts2)))  (cons (first ts1) (merge-trees (rest ts1) ts2))]
          [(< (rank (first ts2)) (rank (first ts1)))  (cons (first ts2) (merge-trees (rest ts2) ts1))]
          [else                                       (insert-tree (link (first ts1) (first ts2))
                                                                   (merge-trees (rest ts1) (rest ts2)))]))
      
      
      ; insert-tree : binomial-tree (list binomial-tree) -> (list binomial-tree)
      ;   the list returned is ordered by rank. Trees of equal rank is linked.
      (define (insert-tree t ts)
        (if (empty? ts)
            (list t)
            (if (< (rank t) (rank (first ts)))
                (cons t ts)
                (insert-tree (link t (first ts)) (rest ts)))))
      
      
      (define (remove-min-tree ts)
        (if (empty? (rest ts))
            (list (first ts) empty)
            (let ([r (remove-min-tree (rest ts))])
              (if (elm<= (root (first ts)) (root (first r)))
                  (list (first ts) (rest ts))
                  (list (first r) (cons (first ts) (second r)))))))
      
      (define (find-min ts)
        (root (first (remove-min-tree ts))))
      
      (define (delete-min ts)
        (let ([p (remove-min-tree ts)])
          (define (insert* xs ts)
            (if (empty? xs)
                ts
                (insert* (rest xs) (insert ts (first xs)))))
          (insert* (node-elm-list (first p))
                      (merge (reverse (node-tree-list (first p)))
                             (second p)))))))
  
  ;;; EXPLICIT-MIN FUNCTOR
  
  (define (explicit-min-heap heap@ element-order@)
    (unit/sig heap^
      (import)
      (define-values/invoke-unit/sig ordered^ element-order@ element)
      
      ; An EXPLICIT-MIN HEAP is either
      ;     empty
      ; or
      ;     (make-explicit-min min base)
      ; where min is an element of type alpha 
      ; and heap is a heap of elements of type alpha.
      
      (define-struct explicit-min (min base))
      
      (define min explicit-min-min)
      (define base explicit-min-base)
      
      (define empty '())
      (define empty? null?)
      
      (define base-heap@ (instantiate-heap heap@ element-order@))
      
      (define-values/invoke-unit/sig heap^ base-heap@ base)
      
      (define find-min min)
      
      (define (merge h1 h2)
        (cond
          [(empty? h1)  h2]
          [(empty? h2)  h1]   
          [else         (if (element:elm< (min h1) (min h2))
                            (make-explicit-min (min h1) (base:merge (base h1) (base h2)))
                            (make-explicit-min (min h2) (base:merge (base h1) (base h2))))]))
      
      (define (insert em x)
        (cond 
          [(empty? em)               (make-explicit-min       x  (base:insert base:empty x))]
          [(element:elm< x (min em)) (make-explicit-min       x  (base:insert (base em) x))]
          [else                      (make-explicit-min (min em) (base:insert (base em) x))]))

      (define (xinsert x h) 
        (insert h x))
    
      (define (insert* em xs)
        (foldl xinsert em xs))

      (define (delete-min em)
        (if (base:empty? (base em))
            empty
            (let ([d (base:delete-min (base em))])
              (cond
                [(base:empty? d) empty]
                [else            (make-explicit-min (base:find-min d) d)]))))))
  
  )